Sub Report()
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim r2max As Long, R As Long, R2 As Long, CL As Long, I As Long
    Dim C As Range, TL, KY

    Application.ScreenUpdating = False
        Set Sh1 = Sheets("Data")
        Set Sh2 = Sheets("1")
    
        Sh1.Copy After:=Sheets(Sheets.Count)
        Set Sh1 = ActiveSheet
        Sh1.Name = "Temp"
    
        On Error Resume Next
        Sh1.Range("B35:B" & Sh1.Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
        r2max = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    
        Sh2.Range("2:" & r2max).ClearContents
        R = 35
    
        While Sh1.Cells(R, 1) <> ""
            KY = Sh1.Cells(R, 2)
            Set C = Sh2.Range("A:A").Find(KY, LookIn:=xlValues)
    
            If Not C Is Nothing Then
                R2 = C.Row
            Else
                R2 = r2max
                For I = 1 To 2
                    Sh2.Cells(R2, I) = Sh1.Cells(R, I + 1)
                Next I
                Sh2.Cells(R2, 3) = Sh1.Cells(R, 12)
                Sh2.Cells(R2, 4) = Sh1.Cells(R, 13)
                r2max = r2max + 1
            End If
    
            CL = 5
            While Sh2.Cells(R2, CL) <> ""
                CL = CL + 2
            Wend
    
            Sh2.Cells(R2, CL) = Sh1.Cells(R, 20)
            Sh2.Cells(R2, CL + 1) = Sh1.Cells(R, 1)
    
            TL = Sh2.Cells(R2, 3)
            For I = 5 To 11 Step 2
                TL = TL - Sh2.Cells(R2, I)
            Next I
    
            Sh2.Cells(R2, 13) = TL
            If TL = 0 Then
                Rows(R2 & ":" & R2).Select
                Selection.ClearContents
                r2max = r2max - 1
            End If
            R = R + 1
        Wend
    
        Application.DisplayAlerts = False
            Sheets("Temp").Delete
        Application.DisplayAlerts = True
    
        Application.Goto Sh2.Range("A1")
        Sh2.Rows(Sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
    Application.ScreenUpdating = True
End Sub